home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / ldb / gc.c < prev    next >
C/C++ Source or Header  |  1992-03-02  |  46KB  |  1,971 lines
  1. /*
  2.  * Stop and Copy GC based on Cheney's algorithm.
  3.  *
  4.  * $Header: gc.c,v 1.32 92/03/02 03:56:01 wlott Exp $
  5.  * 
  6.  * Written by Christopher Hoover.
  7.  */
  8.  
  9. #include <stdio.h>
  10. #include <sys/time.h>
  11. #include <sys/resource.h>
  12. #include <signal.h>
  13. #include "lisp.h"
  14. #include "ldb.h"
  15. #include "os.h"
  16. #include "gc.h"
  17. #include "globals.h"
  18. #include "interrupt.h"
  19. #include "validate.h"
  20. #include "lispregs.h"
  21.  
  22. lispobj *from_space;
  23. lispobj *from_space_free_pointer;
  24.  
  25. lispobj *new_space;
  26. lispobj *new_space_free_pointer;
  27.  
  28. static int (*scavtab[256])();
  29. static lispobj (*transother[256])();
  30. static int (*sizetab[256])();
  31.  
  32. static struct weak_pointer *weak_pointers;
  33.  
  34.  
  35. /* Predicates */
  36.  
  37. #if defined(DEBUG_SPACE_PREDICATES)
  38.  
  39. from_space_p(object)
  40. lispobj object;
  41. {
  42.     lispobj *ptr;
  43.  
  44.     gc_assert(Pointerp(object));
  45.  
  46.     ptr = (lispobj *) PTR(object);
  47.  
  48.     return ((from_space <= ptr) &&
  49.         (ptr < from_space_free_pointer));
  50. }        
  51.  
  52. new_space_p(object)
  53. lispobj object;
  54. {
  55.     lispobj *ptr;
  56.  
  57.     gc_assert(Pointerp(object));
  58.  
  59.     ptr = (lispobj *) PTR(object);
  60.         
  61.     return ((new_space <= ptr) &&
  62.         (ptr < new_space_free_pointer));
  63. }        
  64.  
  65. #else
  66.  
  67. #define from_space_p(ptr) \
  68.     ((from_space <= ((lispobj *) ptr)) && \
  69.      (((lispobj *) ptr) < from_space_free_pointer))
  70.  
  71. #define new_space_p(ptr) \
  72.     ((new_space <= ((lispobj *) ptr)) && \
  73.      (((lispobj *) ptr) < new_space_free_pointer))
  74.  
  75. #endif
  76.  
  77.  
  78. /* GC Lossage */
  79.  
  80. void
  81. gc_lose()
  82. {
  83.     exit(1);
  84. }
  85.  
  86.  
  87. /* Copying Objects */
  88.  
  89. static lispobj
  90. copy_object(object, nwords)
  91. lispobj object;
  92. int nwords;
  93. {
  94.     int tag;
  95.     lispobj *new;
  96.     lispobj *source, *dest;
  97.  
  98.     gc_assert(Pointerp(object));
  99.     gc_assert(from_space_p(object));
  100.     gc_assert((nwords & 0x01) == 0);
  101.  
  102.     /* get tag of object */
  103.     tag = LowtagOf(object);
  104.  
  105.     /* allocate space */
  106.     new = new_space_free_pointer;
  107.     new_space_free_pointer += nwords;
  108.  
  109.     dest = new;
  110.     source = (lispobj *) PTR(object);
  111.  
  112.     /* copy the object */
  113.     while (nwords > 0) {
  114.             dest[0] = source[0];
  115.             dest[1] = source[1];
  116.             dest += 2;
  117.             source += 2;
  118.             nwords -= 2;
  119.     }
  120.  
  121.     /* return lisp pointer of new object */
  122.     return ((lispobj) new) | tag;
  123. }
  124.  
  125.  
  126. /* Collect Garbage */
  127.  
  128. static double tv_diff(x, y)
  129. struct timeval *x, *y;
  130. {
  131.     return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) -
  132.         ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6));
  133. }
  134.  
  135. #define BYTES_ZERO_BEFORE_END (1<<12)
  136.  
  137. static void zero_stack()
  138. {
  139.     unsigned long *ptr = (unsigned long *)current_control_stack_pointer;
  140.  
  141.   search:
  142.     do {
  143.     if (*ptr)
  144.         goto fill;
  145.     ptr++;
  146.     } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
  147.     return;
  148.  
  149.   fill:
  150.     do {
  151.     *ptr++ = 0;
  152.     } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
  153.     goto search;
  154. }
  155.  
  156. collect_garbage()
  157. {
  158. #ifdef PRINTNOISE
  159.     struct timeval start_tv, stop_tv;
  160.     struct rusage start_rusage, stop_rusage;
  161.     double real_time, system_time, user_time;
  162.     double percent_retained, gc_rate;
  163.     unsigned long size_discarded;
  164.     unsigned long size_retained;
  165. #endif
  166.     lispobj *current_static_space_free_pointer;
  167.     unsigned long static_space_size;
  168.     unsigned long control_stack_size, binding_stack_size;
  169.     int oldmask;
  170.     
  171. #ifdef PRINTNOISE
  172.     printf("[Collecting garbage ... \n");
  173.  
  174.     getrusage(RUSAGE_SELF, &start_rusage);
  175.     gettimeofday(&start_tv, (struct timezone *) 0);
  176. #endif
  177.  
  178.     oldmask = sigblock(BLOCKABLE);
  179.  
  180.     current_static_space_free_pointer =
  181.         (lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER);
  182.  
  183.  
  184.     /* Set up from space and new space pointers. */
  185.  
  186.     from_space = current_dynamic_space;
  187. #ifndef ibmrt
  188.     from_space_free_pointer = current_dynamic_space_free_pointer;
  189. #else
  190.     from_space_free_pointer = (lispobj *)SymbolValue(ALLOCATION_POINTER);
  191. #endif
  192.  
  193.     if (current_dynamic_space == dynamic_0_space)
  194.         new_space = dynamic_1_space;
  195.     else if (current_dynamic_space == dynamic_1_space)
  196.         new_space = dynamic_0_space;
  197.     else {
  198.         fprintf(stderr, "GC lossage.  Current dynamic space is bogus!\n");
  199.         gc_lose();
  200.     }
  201.  
  202.     new_space_free_pointer = new_space;
  203.  
  204.  
  205.     /* Initialize the weak pointer list. */
  206.     weak_pointers = (struct weak_pointer *) NULL;
  207.  
  208.  
  209.     /* Scavenge all of the roots. */
  210. #ifdef PRINTNOISE
  211.     printf("Scavenging interrupt contexts ...\n");
  212. #endif
  213.     scavenge_interrupt_contexts();
  214.  
  215. #ifdef PRINTNOISE
  216.     printf("Scavenging interrupt handlers (%d bytes) ...\n",
  217.            sizeof(interrupt_handlers));
  218. #endif
  219.     scavenge((lispobj *) interrupt_handlers,
  220.          sizeof(interrupt_handlers) / sizeof(lispobj));
  221.  
  222.     control_stack_size = current_control_stack_pointer - control_stack;
  223. #ifdef PRINTNOISE
  224.     printf("Scavenging the control stack (%d bytes) ...\n",
  225.            control_stack_size * sizeof(lispobj));
  226. #endif
  227.     scavenge(control_stack, control_stack_size);
  228.  
  229. #ifndef ibmrt
  230.     binding_stack_size = current_binding_stack_pointer - binding_stack;
  231. #else
  232.     binding_stack_size =
  233.         (lispobj *)SymbolValue(BINDING_STACK_POINTER) - binding_stack;
  234. #endif
  235. #ifdef PRINTNOISE
  236.     printf("Scavenging the binding stack (%d bytes) ...\n",
  237.            binding_stack_size * sizeof(lispobj));
  238. #endif
  239.     scavenge(binding_stack, binding_stack_size);
  240.  
  241.     static_space_size = current_static_space_free_pointer - static_space;
  242. #ifdef PRINTNOISE
  243.     printf("Scavenging static space (%d bytes) ...\n",
  244.            static_space_size * sizeof(lispobj));
  245. #endif
  246.     scavenge(static_space, static_space_size);
  247.  
  248.  
  249.     /* Scavenge newspace. */
  250. #ifdef PRINTNOISE
  251.     printf("Scavenging new space (%d bytes) ...\n",
  252.            (new_space_free_pointer - new_space) * sizeof(lispobj));
  253. #endif
  254.     scavenge_newspace();
  255.  
  256.  
  257. #if defined(DEBUG_PRINT_GARBAGE)
  258.     print_garbage(from_space, from_space_free_pointer);
  259. #endif
  260.  
  261.     /* Scan the weak pointers. */
  262. #ifdef PRINTNOISE
  263.     printf("Scanning weak pointers ...\n");
  264. #endif
  265.     scan_weak_pointers();
  266.  
  267.  
  268.     /* Flip spaces. */
  269. #ifdef PRINTNOISE
  270.     printf("Flipping spaces ...\n");
  271. #endif
  272.  
  273.     os_zero((os_vm_address_t) current_dynamic_space,
  274.         (os_vm_size_t) DYNAMIC_SPACE_SIZE);
  275.  
  276.     current_dynamic_space = new_space;
  277. #ifndef ibmrt
  278.     current_dynamic_space_free_pointer = new_space_free_pointer;
  279. #else
  280.     SetSymbolValue(ALLOCATION_POINTER, (lispobj)new_space_free_pointer);
  281. #endif
  282.  
  283. #ifdef PRINTNOISE
  284.     size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
  285.     size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
  286. #endif
  287.  
  288.     /* Zero stack. */
  289. #ifdef PRINTNOISE
  290.     printf("Zeroing empty part of control stack ...\n");
  291. #endif
  292.     zero_stack();
  293.  
  294.     (void) sigsetmask(oldmask);
  295.  
  296.  
  297. #ifdef PRINTNOISE
  298.     gettimeofday(&stop_tv, (struct timezone *) 0);
  299.     getrusage(RUSAGE_SELF, &stop_rusage);
  300.  
  301.     printf("done.]\n");
  302.     
  303.     percent_retained = (((float) size_retained) /
  304.                  ((float) size_discarded)) * 100.0;
  305.  
  306.     printf("Total of %d bytes out of %d bytes retained (%3.2f%%).\n",
  307.            size_retained, size_discarded, percent_retained);
  308.  
  309.     real_time = tv_diff(&stop_tv, &start_tv);
  310.     user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime);
  311.     system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime);
  312.  
  313. #if 0
  314.     printf("Statistics:\n");
  315.     printf("%10.2f sec of real time\n", real_time);
  316.     printf("%10.2f sec of user time,\n", user_time);
  317.     printf("%10.2f sec of system time.\n", system_time);
  318. #else
  319.         printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n",
  320.                real_time, user_time, system_time);
  321. #endif        
  322.  
  323.     gc_rate = ((float) size_retained / (float) (1<<20)) / real_time;
  324.  
  325.     printf("%10.2f M bytes/sec collected.\n", gc_rate);
  326. #endif
  327. }
  328.  
  329.  
  330. /* Scavenging */
  331.  
  332. static
  333. scavenge(start, nwords)
  334. lispobj *start;
  335. long nwords;
  336. {
  337.     while (nwords > 0) {
  338.         lispobj object;
  339.         int type, words_scavenged;
  340.  
  341.         object = *start;
  342.         type = TypeOf(object);
  343.  
  344. #if defined(DEBUG_SCAVENGE_VERBOSE)
  345.         printf("Scavenging object at 0x%08x, object = 0x%08x, type = %d\n",
  346.                (unsigned long) start, (unsigned long) object, type);
  347. #endif
  348.  
  349. #if 0
  350.         words_scavenged = (scavtab[type])(start, object);
  351. #else
  352.                 if (Pointerp(object)) {
  353.                     /* It be a pointer. */
  354.                     if (from_space_p(object)) {
  355.                         /* It currently points to old space.  Check for a */
  356.                         /* forwarding pointer. */
  357.                         lispobj first_word;
  358.  
  359.                         first_word = *((lispobj *)PTR(object));
  360.                         if (Pointerp(first_word) && new_space_p(first_word)) {
  361.                             /* Yep, there be a forwarding pointer. */
  362.                             *start = first_word;
  363.                             words_scavenged = 1;
  364.                         }
  365.                         else {
  366.                             /* Scavenge that pointer. */
  367.                             words_scavenged = (scavtab[type])(start, object);
  368.                         }
  369.                     }
  370.                     else {
  371.                         /* It points somewhere other than oldspace.  Leave */
  372.                         /* it alone. */
  373.                         words_scavenged = 1;
  374.                     }
  375.                 }
  376.                 else if ((object & 3) == 0) {
  377.                     /* It's a fixnum.  Real easy. */
  378.                     words_scavenged = 1;
  379.                 }
  380.                 else {
  381.                     /* It's some random header object. */
  382.                     words_scavenged = (scavtab[type])(start, object);
  383.                 }
  384. #endif
  385.  
  386.         start += words_scavenged;
  387.         nwords -= words_scavenged;
  388.     }
  389.     gc_assert(nwords == 0);
  390. }
  391.  
  392. static
  393. scavenge_newspace()
  394. {
  395.     lispobj *here, *next;
  396.  
  397.     here = new_space;
  398.     while (here < new_space_free_pointer) {
  399.     next = new_space_free_pointer;
  400.     scavenge(here, next - here);
  401.     here = next;
  402.     }
  403. }
  404.  
  405.  
  406. /* Scavenging Interrupt Contexts */
  407.  
  408. scavenge_interrupt_contexts()
  409. {
  410.     int i, index;
  411.     struct sigcontext *context;
  412.  
  413.     index = FIXNUM_TO_INT(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
  414. #if defined(DEBUG_PRINT_CONTEXT_INDEX)
  415.     printf("Number of active contexts: %d\n", index);
  416. #endif
  417.  
  418.     for (i = 0; i < index; i++) {
  419.         context = lisp_interrupt_contexts[i];
  420.         scavenge_interrupt_context(context); 
  421.     }
  422. }
  423.  
  424. #ifdef mips
  425. static int boxed_registers[] = {
  426.     A0, A1, A2, A3, A4, A5, CNAME, LEXENV,
  427.     NFP, OCFP, LRA, L0, L1, L2, CODE
  428. };
  429. #endif
  430. #ifdef sparc
  431. static int boxed_registers[] = {
  432.     A0, A1, A2, A3, A4, A5, OCFP, LRA,
  433.     CNAME, LEXENV, L0, L1, L2, CODE
  434. };
  435. #endif
  436.  
  437. #ifdef ibmrt
  438. static int boxed_registers[] = {
  439.     CODE, CNAME, LEXENV, LRA, A0, A1, A2
  440. };
  441. #endif
  442.  
  443. scavenge_interrupt_context(context)
  444. struct sigcontext *context;
  445. {
  446.     int i;
  447.     unsigned long lip;
  448.     unsigned long lip_offset;
  449.     int lip_register_pair;
  450.     unsigned long pc_code_offset;
  451. #ifdef sparc
  452.     unsigned long npc_code_offset;
  453. #endif
  454.  
  455.     /* Find the LIP's register pair and calculate it's offset */
  456.     /* before we scavenge the context. */
  457.     lip = context->sc_regs[LIP];
  458.     lip_offset = 0x7FFFFFFF;
  459.     lip_register_pair = -1;
  460.     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
  461.         unsigned long reg;
  462.         long offset;
  463.         int index;
  464.  
  465.         index = boxed_registers[i];
  466.         reg = context->sc_regs[index];
  467.         if (PTR(reg) <= lip) {
  468.             offset = lip - reg;
  469.             if (offset < lip_offset) {
  470.                 lip_offset = offset;
  471.                 lip_register_pair = index;
  472.             }
  473.         }
  474.     }
  475.  
  476. #if defined(DEBUG_LIP)
  477.     printf("LIP = %08x, Pair is R%d = %08x, Offset = %08x\n",
  478.            context->sc_regs[LIP],
  479.            lip_register_pair,
  480.            context->sc_regs[lip_register_pair],
  481.            lip_offset);
  482. #endif
  483.  
  484.     /* Compute the PC's offset from the start of the CODE */
  485.     /* register. */
  486.     pc_code_offset = context->sc_pc - context->sc_regs[CODE];
  487. #ifdef sparc
  488.     npc_code_offset = context->sc_npc - context->sc_regs[CODE];
  489. #endif
  490.  
  491. #if defined(DEBUG_PC)
  492.     printf("PC = %08x, CODE = %08x, Offset = %08x\n",
  493.            context->sc_pc, context->sc_regs[CODE], pc_code_offset);
  494. #ifdef sparc
  495.     printf("nPC = %08x, CODE = %08x, Offset = %08x\n",
  496.            context->sc_npc, context->sc_regs[CODE], npc_code_offset);
  497. #endif
  498. #endif
  499.            
  500.     /* Scanvenge all boxed registers in the context. */
  501.     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
  502.         int index;
  503. #if defined(DEBUG_SCAVENGE_REGISTERS)
  504.         unsigned long reg;
  505. #endif
  506.  
  507.         index = boxed_registers[i];
  508. #if defined(DEBUG_SCAVENGE_REGISTERS)
  509.         reg = context->sc_regs[index];
  510. #endif
  511.         scavenge((lispobj *) &(context->sc_regs[index]), 1);
  512. #if defined(DEBUG_SCAVENGE_REGISTERS)
  513.         printf("Scavenged R%d: was 0x%08x now 0x%08x\n",
  514.                index, reg, context->sc_regs[index]);
  515. #endif
  516.     }
  517.  
  518.     /* Fix the LIP */
  519.     context->sc_regs[LIP] =
  520.         context->sc_regs[lip_register_pair] + lip_offset;
  521.     
  522. #if defined(DEBUG_LIP)
  523.     printf("LIP = %08x, Pair is R%d = %08x, Offset = %08x\n",
  524.            context->sc_regs[LIP],
  525.            lip_register_pair,
  526.            context->sc_regs[lip_register_pair],
  527.            lip_offset);
  528. #endif
  529.  
  530.     /* Fix the PC if it was in from space */
  531.     if (from_space_p(context->sc_pc))
  532.         context->sc_pc = context->sc_regs[CODE] + pc_code_offset;
  533. #ifdef sparc
  534.     if (from_space_p(context->sc_npc))
  535.         context->sc_npc = context->sc_regs[CODE] + npc_code_offset;
  536. #endif
  537.  
  538. #if defined(DEBUG_PC)
  539.     printf("PC = %08x, CODE = %08x, Offset = %08x\n",
  540.            context->sc_pc, context->sc_regs[CODE], pc_code_offset);
  541. #ifdef sparc
  542.     printf("PC = %08x, CODE = %08x, Offset = %08x\n",
  543.            context->sc_npc, context->sc_regs[CODE], npc_code_offset);
  544. #endif
  545. #endif
  546.            
  547. }
  548.  
  549.  
  550. /* Debugging Code */
  551.  
  552. print_garbage(from_space, from_space_free_pointer)
  553. lispobj *from_space, *from_space_free_pointer;
  554. {
  555.     lispobj *start;
  556.     int total_words_not_copied;
  557.  
  558.     printf("Scanning from space ...\n");
  559.  
  560.     total_words_not_copied = 0;
  561.     start = from_space;
  562.     while (start < from_space_free_pointer) {
  563.         lispobj object;
  564.         int forwardp, type, nwords;
  565.         lispobj header;
  566.  
  567.         object = *start;
  568.         forwardp = Pointerp(object) && new_space_p(object);
  569.  
  570.         if (forwardp) {
  571.             int tag;
  572.             lispobj *pointer;
  573.  
  574.             tag = LowtagOf(object);
  575.  
  576.             switch (tag) {
  577.             case type_ListPointer:
  578.                 nwords = 2;
  579.                 break;
  580.             case type_StructurePointer:
  581.                 printf("Don't know about structures yet!\n");
  582.                 nwords = 1;
  583.                 break;
  584.             case type_FunctionPointer:
  585.                 nwords = 1;
  586.                 break;
  587.             case type_OtherPointer:
  588.                 pointer = (lispobj *) PTR(object);
  589.                 header = *pointer;
  590.                 type = TypeOf(header);
  591.                 nwords = (sizetab[type])(pointer);
  592.             }
  593.         } else {
  594.             type = TypeOf(object);
  595.             nwords = (sizetab[type])(start);
  596.             total_words_not_copied += nwords;
  597.             printf("%4d words not copied at 0x%08x; ",
  598.                    nwords, (unsigned long) start);
  599.             printf("Header word is 0x%08x\n", (unsigned long) object);
  600.         }
  601.         start += nwords;
  602.     }
  603.     printf("%d total words not copied.\n", total_words_not_copied);
  604. }
  605.  
  606.  
  607. /* Code and Code-Related Objects */
  608.  
  609. static lispobj trans_function_header();
  610. static lispobj trans_closure_function_header();
  611. static lispobj trans_boxed();
  612.  
  613. static
  614. scav_function_pointer(where, object)
  615. lispobj *where, object;
  616. {
  617.     gc_assert(Pointerp(object));
  618.  
  619.     if (from_space_p(object)) {
  620.         lispobj first, *first_pointer;
  621.  
  622.         /* object is a pointer into from space.  check to see */
  623.         /* if it has been forwarded */
  624.         first_pointer = (lispobj *) PTR(object);
  625.         first = *first_pointer;
  626.         
  627.         if (!(Pointerp(first) && new_space_p(first))) {
  628.             int type;
  629.             lispobj copy;
  630.  
  631.             /* must transport object -- object may point */
  632.             /* to either a function header, a closure */
  633.             /* function header, or to a closure header. */
  634.             
  635.             type = TypeOf(first);
  636.             switch (type) {
  637.               case type_FunctionHeader:
  638.                 copy = trans_function_header(object);
  639.                 break;
  640.               case type_ClosureFunctionHeader:
  641.                 copy = trans_closure_function_header(object);
  642.                 break;
  643.               case type_ClosureHeader:
  644.               case type_FuncallableInstanceHeader:
  645.                 copy = trans_boxed(object);
  646.                 break;
  647.               default:
  648.                 fprintf(stderr, "GC lossage.  Bogus function pointer.\n");
  649.                 fprintf(stderr, "Pointer: 0x%08x, Header: 0x%08x\n",
  650.                     (unsigned long) object, (unsigned long) first);
  651.                 gc_lose();
  652.             }
  653.  
  654.             first = *first_pointer = copy;
  655.         }
  656.  
  657.         gc_assert(Pointerp(first));
  658.         gc_assert(!from_space_p(first));
  659.  
  660.         *where = first;
  661.     }
  662.     return 1;
  663. }
  664.  
  665. static struct code *
  666. trans_code(code)
  667. struct code *code;
  668. {
  669.     struct code *new_code;
  670.     lispobj first, l_code, l_new_code;
  671.     int nheader_words, ncode_words, nwords;
  672.     unsigned long displacement;
  673.     lispobj fheaderl, *prev_pointer;
  674.  
  675. #if defined(DEBUG_CODE_GC)
  676.     printf("\nTransporting code object located at 0x%08x.\n",
  677.            (unsigned long) code);
  678. #endif
  679.  
  680.     /* if object has already been transported, just return pointer */
  681.     first = code->header;
  682.     if (Pointerp(first) && new_space_p(first))
  683.         return (struct code *) PTR(first);
  684.     
  685.     gc_assert(TypeOf(first) == type_CodeHeader);
  686.  
  687.     /* prepare to transport the code vector */
  688.     l_code = (lispobj) code | type_OtherPointer;
  689.  
  690.     ncode_words = FIXNUM_TO_INT(code->code_size);
  691.     nheader_words = HeaderValue(code->header);
  692.     nwords = ncode_words + nheader_words;
  693.     nwords = CEILING(nwords, 2);
  694.  
  695.     l_new_code = copy_object(l_code, nwords);
  696.     new_code = (struct code *) PTR(l_new_code);
  697.  
  698.     displacement = l_new_code - l_code;
  699.  
  700. #if defined(DEBUG_CODE_GC)
  701.     printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
  702.            (unsigned long) code, (unsigned long) new_code);
  703.     printf("Code object is %d words long.\n", nwords);
  704. #endif
  705.  
  706.     /* set forwarding pointer */
  707.     code->header = l_new_code;
  708.     
  709.     /* set forwarding pointers for all the function headers in the */
  710.     /* code object.  also fix all self pointers */
  711.  
  712.     fheaderl = code->entry_points;
  713.     prev_pointer = &new_code->entry_points;
  714.  
  715.     while (fheaderl != NIL) {
  716.         struct function_header *fheaderp, *nfheaderp;
  717.         lispobj nfheaderl;
  718.         
  719.         fheaderp = (struct function_header *) PTR(fheaderl);
  720.         gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
  721.  
  722.         /* calcuate the new function pointer and the new */
  723.         /* function header */
  724.         nfheaderl = fheaderl + displacement;
  725.         nfheaderp = (struct function_header *) PTR(nfheaderl);
  726.  
  727.         /* set forwarding pointer */
  728.         fheaderp->header = nfheaderl;
  729.         
  730.         /* fix self pointer */
  731.         nfheaderp->self = nfheaderl;
  732.  
  733.         *prev_pointer = nfheaderl;
  734.  
  735.         fheaderl = fheaderp->next;
  736.         prev_pointer = &nfheaderp->next;
  737.     }
  738.  
  739.     return new_code;
  740. }
  741.  
  742. static
  743. scav_code_header(where, object)
  744. lispobj *where, object;
  745. {
  746.     struct code *code;
  747.     int nheader_words, ncode_words, nwords;
  748.     lispobj fheaderl;
  749.     struct function_header *fheaderp;
  750.  
  751.     code = (struct code *) where;
  752.     ncode_words = FIXNUM_TO_INT(code->code_size);
  753.     nheader_words = HeaderValue(object);
  754.     nwords = ncode_words + nheader_words;
  755.     nwords = CEILING(nwords, 2);
  756.  
  757. #if defined(DEBUG_CODE_GC)
  758.     printf("\nScavening code object at 0x%08x.\n",
  759.            (unsigned long) where);
  760.     printf("Code object is %d words long.\n", nwords);
  761.     printf("Scavenging boxed section of code data block (%d words).\n",
  762.            nheader_words - 1);
  763. #endif
  764.  
  765.     /* Scavenge the boxed section of the code data block */
  766.     scavenge(where + 1, nheader_words - 1);
  767.  
  768.     /* Scavenge the boxed section of each function object in the */
  769.     /* code data block */
  770.     fheaderl = code->entry_points;
  771.     while (fheaderl != NIL) {
  772.         fheaderp = (struct function_header *) PTR(fheaderl);
  773.         gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
  774.         
  775. #if defined(DEBUG_CODE_GC)
  776.         printf("Scavenging boxed section of entry point located at 0x%08x.\n",
  777.                (unsigned long) PTR(fheaderl));
  778. #endif
  779.         scavenge(&fheaderp->name, 1);
  780.         scavenge(&fheaderp->arglist, 1);
  781.         scavenge(&fheaderp->type, 1);
  782.         
  783.         fheaderl = fheaderp->next;
  784.     }
  785.     
  786.     return nwords;
  787. }
  788.  
  789. static lispobj
  790. trans_code_header(object)
  791. lispobj object;
  792. {
  793.     struct code *ncode;
  794.  
  795.     ncode = trans_code((struct code *) PTR(object));
  796.     return (lispobj) ncode | type_OtherPointer;
  797. }
  798.  
  799. static
  800. size_code_header(where)
  801. lispobj *where;
  802. {
  803.     struct code *code;
  804.     int nheader_words, ncode_words, nwords;
  805.  
  806.     code = (struct code *) where;
  807.     
  808.     ncode_words = FIXNUM_TO_INT(code->code_size);
  809.     nheader_words = HeaderValue(code->header);
  810.     nwords = ncode_words + nheader_words;
  811.     nwords = CEILING(nwords, 2);
  812.  
  813.     return nwords;
  814. }
  815.  
  816.  
  817. static
  818. scav_return_pc_header(where, object)
  819. lispobj *where, object;
  820. {
  821.     fprintf(stderr, "GC lossage.  Should not be scavenging a ");
  822.     fprintf(stderr, "Return PC Header.\n");
  823.     fprintf(stderr, "where = 0x%08x, object = 0x%08x",
  824.         (unsigned long) where, (unsigned long) object);
  825.     gc_lose();
  826. }
  827.  
  828. static lispobj
  829. trans_return_pc_header(object)
  830. lispobj object;
  831. {
  832.     struct function_header *return_pc;
  833.     unsigned long offset;
  834.     struct code *code, *ncode;
  835.     
  836.     return_pc = (struct function_header *) PTR(object);
  837.     offset = HeaderValue(return_pc->header) * 4;
  838.  
  839.     /* Transport the whole code object */
  840.     code = (struct code *) ((unsigned long) return_pc - offset);
  841.     ncode = trans_code(code);
  842.  
  843.     return ((lispobj) ncode + offset) | type_OtherPointer;
  844. }
  845.  
  846.  
  847. static
  848. scav_function_header(where, object)
  849. lispobj *where, object;
  850. {
  851.     fprintf(stderr, "GC lossage.  Should not be scavenging a ");
  852.     fprintf(stderr, "Function Header.\n");
  853.     fprintf(stderr, "where = 0x%08x, object = 0x%08x",
  854.         (unsigned long) where, (unsigned long) object);
  855.     gc_lose();
  856. }
  857.  
  858. static lispobj
  859. trans_function_header(object)
  860. lispobj object;
  861. {
  862.     struct function_header *fheader;
  863.     unsigned long offset;
  864.     struct code *code, *ncode;
  865.     
  866.     fheader = (struct function_header *) PTR(object);
  867.     offset = HeaderValue(fheader->header) * 4;
  868.  
  869.     /* Transport the whole code object */
  870.     code = (struct code *) ((unsigned long) fheader - offset);
  871.     ncode = trans_code(code);
  872.  
  873.     return ((lispobj) ncode + offset) | type_FunctionPointer;
  874. }
  875.  
  876.  
  877. static
  878. scav_closure_function_header(where, object)
  879. lispobj *where, object;
  880. {
  881.     fprintf(stderr, "GC lossage.  Should not be scavenging a ");
  882.     fprintf(stderr, "Closure Function Header.\n");
  883.     fprintf(stderr, "where = 0x%08x, object = 0x%08x",
  884.         (unsigned long) where, (unsigned long) object);
  885.     gc_lose();
  886. }
  887.  
  888. static lispobj
  889. trans_closure_function_header(object)
  890. lispobj object;
  891. {
  892.     struct function_header *fheader;
  893.     unsigned long offset;
  894.     struct code *code, *ncode;
  895.     
  896.     fheader = (struct function_header *) PTR(object);
  897.     offset = HeaderValue(fheader->header) * 4;
  898.  
  899.     /* Transport the whole code object */
  900.     code = (struct code *) ((unsigned long) fheader - offset);
  901.     ncode = trans_code(code);
  902.  
  903.     return ((lispobj) ncode + offset) | type_FunctionPointer;
  904. }
  905.  
  906.  
  907. /* Structures */
  908.  
  909. static
  910. scav_structure_pointer(where, object)
  911. lispobj *where, object;
  912. {
  913.     if (from_space_p(object)) {
  914.     lispobj first, *first_pointer;
  915.  
  916.     /* object is a pointer into from space.  check to see */
  917.     /* if it has been forwarded */
  918.     first_pointer = (lispobj *) PTR(object);
  919.     first = *first_pointer;
  920.         
  921.     if (!(Pointerp(first) && new_space_p(first)))
  922.         first = *first_pointer = trans_boxed(object);
  923.     *where = first;
  924.     }
  925.     return 1;
  926. }
  927.  
  928.  
  929. /* Lists and Conses */
  930.  
  931. static lispobj trans_list();
  932.  
  933. static
  934. scav_list_pointer(where, object)
  935. lispobj *where, object;
  936. {
  937.     gc_assert(Pointerp(object));
  938.  
  939.     if (from_space_p(object)) {
  940.         lispobj first, *first_pointer;
  941.  
  942.         /* object is a pointer into from space.  check to see */
  943.         /* if it has been forwarded */
  944.         first_pointer = (lispobj *) PTR(object);
  945.         first = *first_pointer;
  946.         
  947.         if (!(Pointerp(first) && new_space_p(first)))
  948.             first = *first_pointer = trans_list(object);
  949.  
  950.         gc_assert(Pointerp(first));
  951.         gc_assert(!from_space_p(first));
  952.     
  953.         *where = first;
  954.     }
  955.     return 1;
  956. }
  957.  
  958. static lispobj
  959. trans_list(object)
  960. lispobj object;
  961. {
  962.     lispobj new_list_pointer;
  963.     struct cons *cons, *new_cons;
  964.     
  965.     cons = (struct cons *) PTR(object);
  966.  
  967.     /* ### Don't use copy_object here. */
  968.     new_list_pointer = copy_object(object, 2);
  969.     new_cons = (struct cons *) PTR(new_list_pointer);
  970.  
  971.     /* Set forwarding pointer. */
  972.     cons->car = new_list_pointer;
  973.     
  974.     /* Try to linearize the list in the cdr direction to help reduce */
  975.     /* paging. */
  976.  
  977.     while (1) {
  978.         lispobj cdr, new_cdr, first;
  979.         struct cons *cdr_cons, *new_cdr_cons;
  980.  
  981.         cdr = cons->cdr;
  982.  
  983.                 if (LowtagOf(cdr) != type_ListPointer ||
  984.                     !from_space_p(cdr) ||
  985.                     (Pointerp(first = *(lispobj *)PTR(cdr)) &&
  986.                      new_space_p(first)))
  987.                     break;
  988.  
  989.         cdr_cons = (struct cons *) PTR(cdr);
  990.  
  991.         /* ### Don't use copy_object here */
  992.         new_cdr = copy_object(cdr, 2);
  993.         new_cdr_cons = (struct cons *) PTR(new_cdr);
  994.  
  995.         /* Set forwarding pointer */
  996.         cdr_cons->car = new_cdr;
  997.  
  998.         /* Update the cdr of the last cons copied into new */
  999.         /* space to keep the newspace scavenge from having to */
  1000.         /* do it. */
  1001.         new_cons->cdr = new_cdr;
  1002.         
  1003.         cons = cdr_cons;
  1004.         new_cons = new_cdr_cons;
  1005.     }
  1006.  
  1007.     return new_list_pointer;
  1008. }
  1009.  
  1010.  
  1011. /* Scavenging and Transporting Other Pointers */
  1012.  
  1013. static
  1014. scav_other_pointer(where, object)
  1015. lispobj *where, object;
  1016. {
  1017.     gc_assert(Pointerp(object));
  1018.  
  1019.     if (from_space_p(object)) {
  1020.         lispobj first, *first_pointer;
  1021.  
  1022.         /* object is a pointer into from space.  check to see */
  1023.         /* if it has been forwarded */
  1024.         first_pointer = (lispobj *) PTR(object);
  1025.         first = *first_pointer;
  1026.         
  1027.         if (!(Pointerp(first) && new_space_p(first)))
  1028.             first = *first_pointer = 
  1029.                 (transother[TypeOf(first)])(object);
  1030.  
  1031.         gc_assert(Pointerp(first));
  1032.         gc_assert(!from_space_p(first));
  1033.  
  1034.         *where = first;
  1035.     }
  1036.     return 1;
  1037. }
  1038.  
  1039.  
  1040. /* Immediate, Boxed, and Unboxed Objects */
  1041.  
  1042. static
  1043. size_pointer(where)
  1044. lispobj *where;
  1045. {
  1046.     return 1;
  1047. }
  1048.  
  1049.  
  1050. static
  1051. scav_immediate(where, object)
  1052. lispobj *where, object;
  1053. {
  1054.     return 1;
  1055. }
  1056.  
  1057. static lispobj
  1058. trans_immediate(object)
  1059. lispobj object;
  1060. {
  1061.     fprintf(stderr, "GC lossage.  Trying to transport an immediate!?\n");
  1062.     gc_lose();
  1063.     return NIL;
  1064. }
  1065.  
  1066. static
  1067. size_immediate(where)
  1068. lispobj *where;
  1069. {
  1070.     return 1;
  1071. }
  1072.  
  1073.  
  1074. static
  1075. scav_boxed(where, object)
  1076. lispobj *where, object;
  1077. {
  1078.     return 1;
  1079. }
  1080.  
  1081. static lispobj
  1082. trans_boxed(object)
  1083. lispobj object;
  1084. {
  1085.     lispobj header;
  1086.     unsigned long length;
  1087.  
  1088.     gc_assert(Pointerp(object));
  1089.  
  1090.     header = *((lispobj *) PTR(object));
  1091.     length = HeaderValue(header) + 1;
  1092.     length = CEILING(length, 2);
  1093.  
  1094.     return copy_object(object, length);
  1095. }
  1096.  
  1097. static
  1098. size_boxed(where)
  1099. lispobj *where;
  1100. {
  1101.     lispobj header;
  1102.     unsigned long length;
  1103.  
  1104.     header = *where;
  1105.     length = HeaderValue(header) + 1;
  1106.     length = CEILING(length, 2);
  1107.  
  1108.     return length;
  1109. }
  1110.  
  1111. /* Note: on the sparc we don't have to do anything special for symbols, */
  1112. /* cause the raw-function-addr has the correct lowtag. */
  1113. #ifndef sparc
  1114. static
  1115. scav_symbol(where, object)
  1116. lispobj *where, object;
  1117. {
  1118.     struct symbol *symbol;
  1119. #define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
  1120.  
  1121.     symbol = (struct symbol *)where;
  1122.     
  1123.     if ((char *)(symbol->function + RAW_ADDR_OFFSET) == symbol->raw_function_addr) {
  1124.         scavenge(where + 1, sizeof(struct symbol)/sizeof(lispobj) - 1);
  1125.         symbol->raw_function_addr = (char *)(symbol->function + RAW_ADDR_OFFSET);
  1126.         return sizeof(struct symbol) / sizeof(lispobj);
  1127.     }
  1128.     else
  1129.         return 1;
  1130. }
  1131. #endif
  1132.  
  1133. static
  1134. scav_unboxed(where, object)
  1135. lispobj *where, object;
  1136. {
  1137.     unsigned long length;
  1138.  
  1139.     length = HeaderValue(object) + 1;
  1140.     length = CEILING(length, 2);
  1141.  
  1142.     return length;
  1143. }
  1144.  
  1145. static lispobj
  1146. trans_unboxed(object)
  1147. lispobj object;
  1148. {
  1149.     lispobj header;
  1150.     unsigned long length;
  1151.  
  1152.  
  1153.     gc_assert(Pointerp(object));
  1154.  
  1155.     header = *((lispobj *) PTR(object));
  1156.     length = HeaderValue(header) + 1;
  1157.     length = CEILING(length, 2);
  1158.  
  1159.     return copy_object(object, length);
  1160. }
  1161.  
  1162. static
  1163. size_unboxed(where)
  1164. lispobj *where;
  1165. {
  1166.     lispobj header;
  1167.     unsigned long length;
  1168.  
  1169.     header = *where;
  1170.     length = HeaderValue(header) + 1;
  1171.     length = CEILING(length, 2);
  1172.  
  1173.     return length;
  1174. }
  1175.  
  1176.  
  1177. /* Vector-Like Objects */
  1178.  
  1179. #define NWORDS(x,y) (CEILING((x),(y)) / (y))
  1180.  
  1181. static
  1182. scav_string(where, object)
  1183. lispobj *where, object;
  1184. {
  1185.     struct vector *vector;
  1186.     int length, nwords;
  1187.  
  1188.     /* NOTE: Strings contain one more byte of data than the length */
  1189.     /* slot indicates. */
  1190.  
  1191.     vector = (struct vector *) where;
  1192.     length = FIXNUM_TO_INT(vector->length) + 1;
  1193.     nwords = CEILING(NWORDS(length, 4) + 2, 2);
  1194.  
  1195.     return nwords;
  1196. }
  1197.  
  1198. static lispobj
  1199. trans_string(object)
  1200. {
  1201.     struct vector *vector;
  1202.     int length, nwords;
  1203.  
  1204.     gc_assert(Pointerp(object));
  1205.  
  1206.     /* NOTE: Strings contain one more byte of data than the length */
  1207.     /* slot indicates. */
  1208.  
  1209.     vector = (struct vector *) PTR(object);
  1210.     length = FIXNUM_TO_INT(vector->length) + 1;
  1211.     nwords = CEILING(NWORDS(length, 4) + 2, 2);
  1212.  
  1213.     return copy_object(object, nwords);
  1214. }
  1215.  
  1216. static
  1217. size_string(where)
  1218. lispobj *where;
  1219. {
  1220.     struct vector *vector;
  1221.     int length, nwords;
  1222.  
  1223.     /* NOTE: Strings contain one more byte of data than the length */
  1224.     /* slot indicates. */
  1225.  
  1226.     vector = (struct vector *) where;
  1227.     length = FIXNUM_TO_INT(vector->length) + 1;
  1228.     nwords = CEILING(NWORDS(length, 4) + 2, 2);
  1229.  
  1230.     return nwords;
  1231. }
  1232.  
  1233. static
  1234. scav_vector(where, object)
  1235. lispobj *where, object;
  1236. {
  1237.     if (HeaderValue(object) == subtype_VectorValidHashing)
  1238.         *where = (subtype_VectorMustRehash<<type_Bits) | type_SimpleVector;
  1239.  
  1240.     return 1;
  1241. }
  1242.  
  1243.  
  1244. static lispobj
  1245. trans_vector(object)
  1246. lispobj object;
  1247. {
  1248.     struct vector *vector;
  1249.     int length, nwords;
  1250.  
  1251.     gc_assert(Pointerp(object));
  1252.  
  1253.     vector = (struct vector *) PTR(object);
  1254.  
  1255.     length = FIXNUM_TO_INT(vector->length);
  1256.     nwords = CEILING(length + 2, 2);
  1257.  
  1258.     return copy_object(object, nwords);
  1259. }
  1260.  
  1261. static
  1262. size_vector(where)
  1263. lispobj *where;
  1264. {
  1265.     struct vector *vector;
  1266.     int length, nwords;
  1267.  
  1268.     vector = (struct vector *) where;
  1269.     length = FIXNUM_TO_INT(vector->length);
  1270.     nwords = CEILING(length + 2, 2);
  1271.  
  1272.     return nwords;
  1273. }
  1274.  
  1275.  
  1276. static
  1277. scav_vector_bit(where, object)
  1278. lispobj *where, object;
  1279. {
  1280.     struct vector *vector;
  1281.     int length, nwords;
  1282.  
  1283.     vector = (struct vector *) where;
  1284.     length = FIXNUM_TO_INT(vector->length);
  1285.     nwords = CEILING(NWORDS(length, 32) + 2, 2);
  1286.  
  1287.     return nwords;
  1288. }
  1289.  
  1290. static lispobj
  1291. trans_vector_bit(object)
  1292. lispobj object;
  1293. {
  1294.     struct vector *vector;
  1295.     int length, nwords;
  1296.  
  1297.     gc_assert(Pointerp(object));
  1298.  
  1299.     vector = (struct vector *) PTR(object);
  1300.     length = FIXNUM_TO_INT(vector->length);
  1301.     nwords = CEILING(NWORDS(length, 32) + 2, 2);
  1302.  
  1303.     return copy_object(object, nwords);
  1304. }
  1305.  
  1306. static
  1307. size_vector_bit(where)
  1308. lispobj *where;
  1309. {
  1310.     struct vector *vector;
  1311.     int length, nwords;
  1312.  
  1313.     vector = (struct vector *) where;
  1314.     length = FIXNUM_TO_INT(vector->length);
  1315.     nwords = CEILING(NWORDS(length, 32) + 2, 2);
  1316.  
  1317.     return nwords;
  1318. }
  1319.  
  1320.  
  1321. static
  1322. scav_vector_unsigned_byte_2(where, object)
  1323. lispobj *where, object;
  1324. {
  1325.     struct vector *vector;
  1326.     int length, nwords;
  1327.  
  1328.     vector = (struct vector *) where;
  1329.     length = FIXNUM_TO_INT(vector->length);
  1330.     nwords = CEILING(NWORDS(length, 16) + 2, 2);
  1331.  
  1332.     return nwords;
  1333. }
  1334.  
  1335. static lispobj
  1336. trans_vector_unsigned_byte_2(object)
  1337. lispobj object;
  1338. {
  1339.     struct vector *vector;
  1340.     int length, nwords;
  1341.  
  1342.     gc_assert(Pointerp(object));
  1343.  
  1344.     vector = (struct vector *) PTR(object);
  1345.     length = FIXNUM_TO_INT(vector->length);
  1346.     nwords = CEILING(NWORDS(length, 16) + 2, 2);
  1347.  
  1348.     return copy_object(object, nwords);
  1349. }
  1350.  
  1351. static
  1352. size_vector_unsigned_byte_2(where)
  1353. lispobj *where;
  1354. {
  1355.     struct vector *vector;
  1356.     int length, nwords;
  1357.  
  1358.     vector = (struct vector *) where;
  1359.     length = FIXNUM_TO_INT(vector->length);
  1360.     nwords = CEILING(NWORDS(length, 16) + 2, 2);
  1361.  
  1362.     return nwords;
  1363. }
  1364.  
  1365.  
  1366. static
  1367. scav_vector_unsigned_byte_4(where, object)
  1368. lispobj *where, object;
  1369. {
  1370.     struct vector *vector;
  1371.     int length, nwords;
  1372.  
  1373.     vector = (struct vector *) where;
  1374.     length = FIXNUM_TO_INT(vector->length);
  1375.     nwords = CEILING(NWORDS(length, 8) + 2, 2);
  1376.  
  1377.     return nwords;
  1378. }
  1379.  
  1380. static lispobj
  1381. trans_vector_unsigned_byte_4(object)
  1382. lispobj object;
  1383. {
  1384.     struct vector *vector;
  1385.     int length, nwords;
  1386.  
  1387.     gc_assert(Pointerp(object));
  1388.  
  1389.     vector = (struct vector *) PTR(object);
  1390.     length = FIXNUM_TO_INT(vector->length);
  1391.     nwords = CEILING(NWORDS(length, 8) + 2, 2);
  1392.  
  1393.     return copy_object(object, nwords);
  1394. }
  1395.  
  1396. static
  1397. size_vector_unsigned_byte_4(where, object)
  1398. lispobj *where, object;
  1399. {
  1400.     struct vector *vector;
  1401.     int length, nwords;
  1402.  
  1403.     vector = (struct vector *) where;
  1404.     length = FIXNUM_TO_INT(vector->length);
  1405.     nwords = CEILING(NWORDS(length, 8) + 2, 2);
  1406.  
  1407.     return nwords;
  1408. }
  1409.  
  1410.  
  1411. static
  1412. scav_vector_unsigned_byte_8(where, object)
  1413. lispobj *where, object;
  1414. {
  1415.     struct vector *vector;
  1416.     int length, nwords;
  1417.  
  1418.     vector = (struct vector *) where;
  1419.     length = FIXNUM_TO_INT(vector->length);
  1420.     nwords = CEILING(NWORDS(length, 4) + 2, 2);
  1421.  
  1422.     return nwords;
  1423. }
  1424.  
  1425. static lispobj
  1426. trans_vector_unsigned_byte_8(object)
  1427. lispobj object;
  1428. {
  1429.     struct vector *vector;
  1430.     int length, nwords;
  1431.  
  1432.     gc_assert(Pointerp(object));
  1433.  
  1434.     vector = (struct vector *) PTR(object);
  1435.     length = FIXNUM_TO_INT(vector->length);
  1436.     nwords = CEILING(NWORDS(length, 4) + 2, 2);
  1437.  
  1438.     return copy_object(object, nwords);
  1439. }
  1440.  
  1441. static
  1442. size_vector_unsigned_byte_8(where)
  1443. lispobj *where;
  1444. {
  1445.     struct vector *vector;
  1446.     int length, nwords;
  1447.  
  1448.     vector = (struct vector *) where;
  1449.     length = FIXNUM_TO_INT(vector->length);
  1450.     nwords = CEILING(NWORDS(length, 4) + 2, 2);
  1451.  
  1452.     return nwords;
  1453. }
  1454.  
  1455.  
  1456. static
  1457. scav_vector_unsigned_byte_16(where, object)
  1458. lispobj *where, object;
  1459. {
  1460.     struct vector *vector;
  1461.     int length, nwords;
  1462.  
  1463.     vector = (struct vector *) where;
  1464.     length = FIXNUM_TO_INT(vector->length);
  1465.     nwords = CEILING(NWORDS(length, 2) + 2, 2);
  1466.  
  1467.     return nwords;
  1468. }
  1469.  
  1470. static lispobj
  1471. trans_vector_unsigned_byte_16(object)
  1472. lispobj object;
  1473. {
  1474.     struct vector *vector;
  1475.     int length, nwords;
  1476.  
  1477.     gc_assert(Pointerp(object));
  1478.  
  1479.     vector = (struct vector *) PTR(object);
  1480.     length = FIXNUM_TO_INT(vector->length);
  1481.     nwords = CEILING(NWORDS(length, 2) + 2, 2);
  1482.  
  1483.     return copy_object(object, nwords);
  1484. }
  1485.  
  1486. static
  1487. size_vector_unsigned_byte_16(where)
  1488. lispobj *where;
  1489. {
  1490.     struct vector *vector;
  1491.     int length, nwords;
  1492.  
  1493.     vector = (struct vector *) where;
  1494.     length = FIXNUM_TO_INT(vector->length);
  1495.     nwords = CEILING(NWORDS(length, 2) + 2, 2);
  1496.  
  1497.     return nwords;
  1498. }
  1499.  
  1500.  
  1501. static
  1502. scav_vector_unsigned_byte_32(where, object)
  1503. lispobj *where, object;
  1504. {
  1505.     struct vector *vector;
  1506.     int length, nwords;
  1507.  
  1508.     vector = (struct vector *) where;
  1509.     length = FIXNUM_TO_INT(vector->length);
  1510.     nwords = CEILING(length + 2, 2);
  1511.  
  1512.     return nwords;
  1513. }
  1514.  
  1515. static lispobj
  1516. trans_vector_unsigned_byte_32(object)
  1517. lispobj object;
  1518. {
  1519.     struct vector *vector;
  1520.     int length, nwords;
  1521.  
  1522.     gc_assert(Pointerp(object));
  1523.  
  1524.     vector = (struct vector *) PTR(object);
  1525.     length = FIXNUM_TO_INT(vector->length);
  1526.     nwords = CEILING(length + 2, 2);
  1527.  
  1528.     return copy_object(object, nwords);
  1529. }
  1530.  
  1531. static
  1532. size_vector_unsigned_byte_32(where)
  1533. lispobj *where;
  1534. {
  1535.     struct vector *vector;
  1536.     int length, nwords;
  1537.  
  1538.     vector = (struct vector *) where;
  1539.     length = FIXNUM_TO_INT(vector->length);
  1540.     nwords = CEILING(length + 2, 2);
  1541.  
  1542.     return nwords;
  1543. }
  1544.  
  1545.  
  1546. static
  1547. scav_vector_single_float(where, object)
  1548. lispobj *where, object;
  1549. {
  1550.     struct vector *vector;
  1551.     int length, nwords;
  1552.  
  1553.     vector = (struct vector *) where;
  1554.     length = FIXNUM_TO_INT(vector->length);
  1555.     nwords = CEILING(length + 2, 2);
  1556.  
  1557.     return nwords;
  1558. }
  1559.  
  1560. static lispobj
  1561. trans_vector_single_float(object)
  1562. lispobj object;
  1563. {
  1564.     struct vector *vector;
  1565.     int length, nwords;
  1566.  
  1567.     gc_assert(Pointerp(object));
  1568.  
  1569.     vector = (struct vector *) PTR(object);
  1570.     length = FIXNUM_TO_INT(vector->length);
  1571.     nwords = CEILING(length + 2, 2);
  1572.  
  1573.     return copy_object(object, nwords);
  1574. }
  1575.  
  1576. static
  1577. size_vector_single_float(where)
  1578. lispobj *where;
  1579. {
  1580.     struct vector *vector;
  1581.     int length, nwords;
  1582.  
  1583.     vector = (struct vector *) where;
  1584.     length = FIXNUM_TO_INT(vector->length);
  1585.     nwords = CEILING(length + 2, 2);
  1586.  
  1587.     return nwords;
  1588. }
  1589.  
  1590.  
  1591. static
  1592. scav_vector_double_float(where, object)
  1593. lispobj *where, object;
  1594. {
  1595.     struct vector *vector;
  1596.     int length, nwords;
  1597.  
  1598.     vector = (struct vector *) where;
  1599.     length = FIXNUM_TO_INT(vector->length);
  1600.     nwords = CEILING(length * 2 + 2, 2);
  1601.  
  1602.     return nwords;
  1603. }
  1604.  
  1605. static lispobj
  1606. trans_vector_double_float(object)
  1607. lispobj object;
  1608. {
  1609.     struct vector *vector;
  1610.     int length, nwords;
  1611.  
  1612.     gc_assert(Pointerp(object));
  1613.  
  1614.     vector = (struct vector *) PTR(object);
  1615.     length = FIXNUM_TO_INT(vector->length);
  1616.     nwords = CEILING(length * 2 + 2, 2);
  1617.  
  1618.     return copy_object(object, nwords);
  1619. }
  1620.  
  1621. static
  1622. size_vector_double_float(where)
  1623. lispobj *where;
  1624. {
  1625.     struct vector *vector;
  1626.     int length, nwords;
  1627.  
  1628.     vector = (struct vector *) where;
  1629.     length = FIXNUM_TO_INT(vector->length);
  1630.     nwords = CEILING(length * 2 + 2, 2);
  1631.  
  1632.     return nwords;
  1633. }
  1634.  
  1635.  
  1636. /* Weak Pointers */
  1637.  
  1638. #define WEAK_POINTER_NWORDS \
  1639.     CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
  1640.  
  1641. static
  1642. scav_weak_pointer(where, object)
  1643. lispobj *where, object;
  1644. {
  1645.     /* Do not let GC scavenge the value slot of the weak pointer */
  1646.     /* (that is why it is a weak pointer).  Note:  we could use */
  1647.     /* the scav_unboxed method here. */
  1648.  
  1649.     return WEAK_POINTER_NWORDS;
  1650. }
  1651.  
  1652. static lispobj
  1653. trans_weak_pointer(object)
  1654. lispobj object;
  1655. {
  1656.     lispobj copy;
  1657.     struct weak_pointer *wp;
  1658.  
  1659.     gc_assert(Pointerp(object));
  1660.  
  1661. #if defined(DEBUG_WEAK)
  1662.     printf("Transporting weak pointer from 0x%08x\n", object);
  1663. #endif
  1664.  
  1665.     /* Need to remember where all the weak pointers are that have */
  1666.     /* been transported so they can be fixed up in a post-GC pass. */
  1667.  
  1668.     copy = copy_object(object, WEAK_POINTER_NWORDS);
  1669.     wp = (struct weak_pointer *) PTR(copy);
  1670.     
  1671.  
  1672.     /* Push the weak pointer onto the list of weak pointers. */
  1673.     wp->next = weak_pointers;
  1674.     weak_pointers = wp;
  1675.  
  1676.     return copy;
  1677. }
  1678.  
  1679. static
  1680. size_weak_pointer(where)
  1681. lispobj *where;
  1682. {
  1683.     return WEAK_POINTER_NWORDS;
  1684. }
  1685.  
  1686. scan_weak_pointers()
  1687. {
  1688.     struct weak_pointer *wp;
  1689.  
  1690.     for (wp = weak_pointers; wp != (struct weak_pointer *) NULL;
  1691.          wp = wp->next) {
  1692.         lispobj value;
  1693.         lispobj first, *first_pointer;
  1694.  
  1695.         value = wp->value;
  1696.  
  1697. #if defined(DEBUG_WEAK)
  1698.         printf("Weak pointer at 0x%08x\n", (unsigned long) wp);
  1699.         printf("Value: 0x%08x\n", (unsigned long) value);
  1700. #endif        
  1701.  
  1702.         if (!(Pointerp(value) && from_space_p(value)))
  1703.             continue;
  1704.  
  1705.         /* Now, we need to check if the object has been */
  1706.         /* forwarded.  If it has been, the weak pointer is */
  1707.         /* still good and needs to be updated.  Otherwise, the */
  1708.         /* weak pointer needs to be nil'ed out. */
  1709.  
  1710.         first_pointer = (lispobj *) PTR(value);
  1711.         first = *first_pointer;
  1712.         
  1713. #if defined(DEBUG_WEAK)
  1714.         printf("First: 0x%08x\n", (unsigned long) first);
  1715. #endif        
  1716.  
  1717.         if (Pointerp(first) && new_space_p(first))
  1718.             wp->value = first;
  1719.         else {
  1720.             wp->value = NIL;
  1721.             wp->broken = T;
  1722.         }
  1723.     }
  1724. }
  1725.  
  1726.  
  1727.  
  1728. /* Initialization */
  1729.  
  1730. static
  1731. scav_lose(object)
  1732. lispobj object;
  1733. {
  1734.     fprintf(stderr, "GC lossage.  No scavenge function for object 0x%08x\n",
  1735.         (unsigned long) object);
  1736.     gc_lose();
  1737.     return 0;
  1738. }
  1739.  
  1740. static lispobj
  1741. trans_lose(object)
  1742. lispobj object;
  1743. {
  1744.     fprintf(stderr, "GC lossage.  No transport function for object 0x%08x\n",
  1745.         (unsigned long) object);
  1746.     gc_lose();
  1747.     return NIL;
  1748. }
  1749.  
  1750. static
  1751. size_lose(where)
  1752. lispobj *where;
  1753. {
  1754.     fprintf(stderr, "Size lossage.  No size function for object at 0x%08x\n",
  1755.         (unsigned long) where);
  1756.     fprintf(stderr, "First word of object: 0x%08x\n",
  1757.         (unsigned long) *where);
  1758.     return 1;
  1759. }
  1760.  
  1761. gc_init()
  1762. {
  1763.     int i;
  1764.  
  1765.     /* Scavenge Table */
  1766.     for (i = 0; i < 256; i++)
  1767.         scavtab[i] = scav_lose;
  1768.  
  1769.     for (i = 0; i < 32; i++) {
  1770.         scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
  1771.         scavtab[type_FunctionPointer|(i<<3)] = scav_function_pointer;
  1772.         /* OtherImmediate0 */
  1773.         scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
  1774.         scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
  1775.         scavtab[type_StructurePointer|(i<<3)] = scav_structure_pointer;
  1776.         /* OtherImmediate1 */
  1777.         scavtab[type_OtherPointer|(i<<3)] = scav_other_pointer;
  1778.     }
  1779.  
  1780.     scavtab[type_Bignum] = scav_unboxed;
  1781.     scavtab[type_Ratio] = scav_boxed;
  1782.     scavtab[type_SingleFloat] = scav_unboxed;
  1783.     scavtab[type_DoubleFloat] = scav_unboxed;
  1784.     scavtab[type_Complex] = scav_boxed;
  1785.     scavtab[type_SimpleArray] = scav_boxed;
  1786.     scavtab[type_SimpleString] = scav_string;
  1787.     scavtab[type_SimpleBitVector] = scav_vector_bit;
  1788.     scavtab[type_SimpleVector] = scav_vector;
  1789.     scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2;
  1790.     scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4;
  1791.     scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8;
  1792.     scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16;
  1793.     scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32;
  1794.     scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
  1795.     scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
  1796.     scavtab[type_ComplexString] = scav_boxed;
  1797.     scavtab[type_ComplexBitVector] = scav_boxed;
  1798.     scavtab[type_ComplexVector] = scav_boxed;
  1799.     scavtab[type_ComplexArray] = scav_boxed;
  1800.     scavtab[type_CodeHeader] = scav_code_header;
  1801.     scavtab[type_FunctionHeader] = scav_function_header;
  1802.     scavtab[type_ClosureFunctionHeader] = scav_closure_function_header;
  1803.     scavtab[type_ReturnPcHeader] = scav_return_pc_header;
  1804.     scavtab[type_ClosureHeader] = scav_boxed;
  1805.     scavtab[type_FuncallableInstanceHeader] = scav_boxed;
  1806.     scavtab[type_ValueCellHeader] = scav_boxed;
  1807. #ifndef sparc
  1808.         scavtab[type_SymbolHeader] = scav_symbol;
  1809. #else
  1810.         scavtab[type_SymbolHeader] = scav_boxed;
  1811. #endif
  1812.     scavtab[type_BaseChar] = scav_immediate;
  1813.     scavtab[type_Sap] = scav_unboxed;
  1814.     scavtab[type_UnboundMarker] = scav_immediate;
  1815.     scavtab[type_WeakPointer] = scav_weak_pointer;
  1816.         scavtab[type_StructureHeader] = scav_boxed;
  1817.  
  1818.  
  1819.     /* Transport Other Table */
  1820.     for (i = 0; i < 256; i++)
  1821.         transother[i] = trans_lose;
  1822.  
  1823.     transother[type_Bignum] = trans_unboxed;
  1824.     transother[type_Ratio] = trans_boxed;
  1825.     transother[type_SingleFloat] = trans_unboxed;
  1826.     transother[type_DoubleFloat] = trans_unboxed;
  1827.     transother[type_Complex] = trans_boxed;
  1828.     transother[type_SimpleArray] = trans_boxed;
  1829.     transother[type_SimpleString] = trans_string;
  1830.     transother[type_SimpleBitVector] = trans_vector_bit;
  1831.     transother[type_SimpleVector] = trans_vector;
  1832.     transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2;
  1833.     transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4;
  1834.     transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8;
  1835.     transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16;
  1836.     transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32;
  1837.     transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
  1838.     transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
  1839.     transother[type_ComplexString] = trans_boxed;
  1840.     transother[type_ComplexBitVector] = trans_boxed;
  1841.     transother[type_ComplexVector] = trans_boxed;
  1842.     transother[type_ComplexArray] = trans_boxed;
  1843.     transother[type_CodeHeader] = trans_code_header;
  1844.     transother[type_FunctionHeader] = trans_function_header;
  1845.     transother[type_ClosureFunctionHeader] = trans_closure_function_header;
  1846.     transother[type_ReturnPcHeader] = trans_return_pc_header;
  1847.     transother[type_ClosureHeader] = trans_boxed;
  1848.     transother[type_FuncallableInstanceHeader] = trans_boxed;
  1849.     transother[type_ValueCellHeader] = trans_boxed;
  1850.     transother[type_SymbolHeader] = trans_boxed;
  1851.     transother[type_BaseChar] = trans_immediate;
  1852.     transother[type_Sap] = trans_unboxed;
  1853.     transother[type_UnboundMarker] = trans_immediate;
  1854.     transother[type_WeakPointer] = trans_weak_pointer;
  1855.         transother[type_StructureHeader] = trans_vector;
  1856.  
  1857.     /* Size table */
  1858.  
  1859.     for (i = 0; i < 256; i++)
  1860.         sizetab[i] = size_lose;
  1861.  
  1862.     for (i = 0; i < 32; i++) {
  1863.         sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
  1864.         sizetab[type_FunctionPointer|(i<<3)] = size_pointer;
  1865.         /* OtherImmediate0 */
  1866.         sizetab[type_ListPointer|(i<<3)] = size_pointer;
  1867.         sizetab[type_OddFixnum|(i<<3)] = size_immediate;
  1868.         sizetab[type_StructurePointer|(i<<3)] = size_pointer;
  1869.         /* OtherImmediate1 */
  1870.         sizetab[type_OtherPointer|(i<<3)] = size_pointer;
  1871.     }
  1872.  
  1873.     sizetab[type_Bignum] = size_unboxed;
  1874.     sizetab[type_Ratio] = size_boxed;
  1875.     sizetab[type_SingleFloat] = size_unboxed;
  1876.     sizetab[type_DoubleFloat] = size_unboxed;
  1877.     sizetab[type_Complex] = size_boxed;
  1878.     sizetab[type_SimpleArray] = size_boxed;
  1879.     sizetab[type_SimpleString] = size_string;
  1880.     sizetab[type_SimpleBitVector] = size_vector_bit;
  1881.     sizetab[type_SimpleVector] = size_vector;
  1882.     sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2;
  1883.     sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4;
  1884.     sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8;
  1885.     sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16;
  1886.     sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32;
  1887.     sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
  1888.     sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
  1889.     sizetab[type_ComplexString] = size_boxed;
  1890.     sizetab[type_ComplexBitVector] = size_boxed;
  1891.     sizetab[type_ComplexVector] = size_boxed;
  1892.     sizetab[type_ComplexArray] = size_boxed;
  1893.     sizetab[type_CodeHeader] = size_code_header;
  1894. #if 0
  1895.     /* Shouldn't see these so just lose if it happens */
  1896.     sizetab[type_FunctionHeader] = size_function_header;
  1897.     sizetab[type_ClosureFunctionHeader] = size_closure_function_header;
  1898.     sizetab[type_ReturnPcHeader] = size_return_pc_header;
  1899. #endif
  1900.     sizetab[type_ClosureHeader] = size_boxed;
  1901.     sizetab[type_FuncallableInstanceHeader] = size_boxed;
  1902.     sizetab[type_ValueCellHeader] = size_boxed;
  1903.     sizetab[type_SymbolHeader] = size_boxed;
  1904.     sizetab[type_BaseChar] = size_immediate;
  1905.     sizetab[type_Sap] = size_unboxed;
  1906.     sizetab[type_UnboundMarker] = size_immediate;
  1907.     sizetab[type_WeakPointer] = size_weak_pointer;
  1908.         sizetab[type_StructureHeader] = size_vector;
  1909. }
  1910.  
  1911.  
  1912.  
  1913. /* Noise to manipulate the gc trigger stuff. */
  1914.  
  1915. #ifndef ibmrt
  1916.  
  1917. void set_auto_gc_trigger(dynamic_usage)
  1918.      unsigned long dynamic_usage;
  1919. {
  1920.     os_vm_address_t addr=(os_vm_address_t)current_dynamic_space + dynamic_usage;
  1921.     os_vm_size_t length=
  1922.     DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
  1923.  
  1924.     if(addr < (os_vm_address_t)current_dynamic_space_free_pointer) {
  1925.     fprintf(stderr,
  1926.        "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %d)\n",
  1927.         dynamic_usage,
  1928.         (os_vm_address_t)current_dynamic_space_free_pointer
  1929.         - (os_vm_address_t)current_dynamic_space);
  1930.     return;
  1931.     }
  1932.     else if (length < 0) {
  1933.     fprintf(stderr,
  1934.         "set_auto_gc_trigger: tried to set gc trigger too high! (%d)\n",
  1935.         dynamic_usage);
  1936.     return;
  1937.     }
  1938.  
  1939.     addr=os_round_up_to_page(addr);
  1940.     length=os_trunc_size_to_page(length);
  1941.  
  1942. #ifndef MACH
  1943.     os_invalidate(addr,length);
  1944. #else
  1945.     os_protect(addr, length, 0);
  1946. #endif
  1947.  
  1948.     current_auto_gc_trigger = (lispobj *)addr;
  1949. }
  1950.  
  1951. void clear_auto_gc_trigger()
  1952. {
  1953.     if(current_auto_gc_trigger!=NULL){
  1954. #ifndef MACH /* don't want to force whole space into swapping mode... */
  1955.     os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger;
  1956.     os_vm_size_t length=
  1957.         DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
  1958.  
  1959.     os_validate(addr,length);
  1960. #else
  1961.     os_protect((os_vm_address_t)current_dynamic_space,
  1962.            DYNAMIC_SPACE_SIZE,
  1963.            OS_VM_PROT_ALL);
  1964. #endif
  1965.  
  1966.     current_auto_gc_trigger = NULL;
  1967.     }
  1968. }
  1969.  
  1970. #endif
  1971.